home *** CD-ROM | disk | FTP | other *** search
/ Whiteline: Alpha / Whiteline Alpha.iso / progtool / modula2 / excard / excard.mod < prev    next >
Encoding:
Modula Implementation  |  1994-09-22  |  25.2 KB  |  602 lines
  1. IMPLEMENTATION MODULE Excard;
  2.  
  3. (*             Implementationsmodul Excard Version 1.0                *
  4.  *        Copyright: K. Hartlage, Pr.Stroehen 194, 4993 Rahden        *
  5.  * Berechnung (Ex-)tra langer (Card-)inalzahlen;                      *
  6.  * Es kann natuerlich keine Gewaehr fuer die Richtigkeit der          *
  7.  * Prozeduren gegeben werden.                                         *
  8.  * Verbesserungen, Berichtigungen und eigene Anwendungen bitte an die *
  9.  * obige Adresse senden                                               *)
  10.  
  11. (*$T-*) (* Achtung: range checking ausgeschaltet *) 
  12.  
  13. FROM SYSTEM   IMPORT ADR,ADDRESS,CODE;
  14.  
  15. FROM Strings  IMPORT String,Length;
  16.  
  17. FROM InOut    IMPORT Write,WriteLn,ReadString,WriteString;  
  18.  
  19. CONST         TwoPow16 = 65536; 
  20.  
  21. TYPE          pChar    = POINTER TO CHAR;
  22.               pCard    = POINTER TO CARDINAL;
  23.   
  24. (*$P-*)
  25. PROCEDURE Def(VAR a : ExCard; b : ADDRESS);
  26. (*  a := b  *)
  27. BEGIN
  28. CODE(048E7H,08018H);      (*    def     movem.l d0/a3-a4,-(sp)*)
  29. CODE(0266FH,00010H);      (*            movea.l $10(sp),a3 ;^b*)
  30. CODE(0286FH,00014H);      (*            movea.l $14(sp),a4 ;^a *)
  31. CODE(03013H);             (*            move.w (a3),d0*)
  32. CODE(0E248H);             (*            lsr.w #1,d0*)
  33. CODE(028DBH);             (*    l5      move.l (a3)+,(a4)+*)
  34. CODE(051C8H,0FFFCH);      (*            dbf d0,l5*)
  35. CODE(04CDFH,01801H);      (*            movem.l (sp)+,d0/a3-a4*)
  36. CODE(04E75H);             (*            rts*)
  37. END Def;
  38.  
  39. (*$P-*)  
  40. PROCEDURE CardToExCard( VAR a : ExCard; b : CARDINAL);
  41. (* a := b         *)
  42. BEGIN
  43. CODE(02F0CH);             (*               move.l a4,-(sp)*)
  44. CODE(0286FH,0000AH);      (*               movea.l $A(sp),a4*)
  45. CODE(038FCH,00001H);      (*               move.w #1,(a4)+*)
  46. CODE(038AFH,00008H);      (*               move.w $8(sp),(a4)*)
  47. CODE(0285FH);             (*               movea.l (sp)+,a4*)
  48. CODE(04E75H);             (*               rts*)
  49. END CardToExCard;
  50.  
  51. (*$P-*)
  52. PROCEDURE ExEqual(VAR a,b : ExCard) : BOOLEAN;
  53. (* a = b ?       *)
  54. BEGIN
  55. CODE(048E7H,08018H);        (*  equal   movem.l d0/a3-a4,-(sp)*)
  56. CODE(0286FH,00010H);        (*          movea.l $10(sp),a4*)
  57. CODE(0266FH,00014H);        (*          movea.l $14(sp),a3*)
  58. CODE(03014H);               (*          move.w (a4),d0*)
  59. CODE(0B74CH);               (*  l8      cmpm.w (a4)+,(a3)+*)
  60. CODE(056C8H,0FFFCH);        (*          dbne d0,l8*)
  61. CODE(06700H,0000CH);        (*          beq equtrue*)
  62. CODE(04CDFH,01801H);        (*          movem.l (sp)+,d0/a3-a4*)
  63. CODE(0422FH,0000CH);        (*          clr.b $C(sp)*)
  64. CODE(04E75H);               (*          rts*)
  65. CODE(04CDFH,01801H);        (*  equtrue movem.l (sp)+,d0/a3-a4*)
  66. CODE(01F7CH,00001H,0000CH); (*          move.b #1,$C(sp)*)
  67. CODE(04E75H);               (*          rts*)
  68. END ExEqual;
  69.  
  70. (*$P-*)
  71. PROCEDURE ExLess (VAR a,b : ExCard) : BOOLEAN;
  72. (*  a < b ?     *)
  73. BEGIN
  74. CODE(048E7H,0C018H);       (*   less    movem.l d0-d1/a3-a4,-(sp)*)
  75. CODE(0266FH,00014H);       (*           movea.l 20(sp),a3*)
  76. CODE(0286FH,00018H);       (*           movea.l 24(sp),a4*)
  77. CODE(0301BH);              (*           move.w (a3)+,d0*)
  78. CODE(0B05CH);              (*           cmp.w (a4)+,d0*)
  79. CODE(06500H,00030H);       (*           bcs lesfals*)
  80. CODE(06200H,00020H);       (*           bhi lestrue*)
  81. CODE(03200H);              (*           move.w d0,d1*)
  82. CODE(05341H);              (*           subq.w #1,d1*)
  83. CODE(0D040H);              (*           add.w d0,d0*)
  84. CODE(049F4H,00000H);       (*           lea $0(a4,d0.w),a4*)
  85. CODE(047F3H,00000H);       (*           lea $0(a3,d0.w),a3*)
  86. CODE(03023H);              (*   loop    move.w -(a3),d0*)
  87. CODE(0B064H);              (*           cmp.w -(a4),d0*)
  88. CODE(06500H,00016H);       (*           bcs lesfals*)
  89. CODE(056C9H,0FFF6H);       (*           dbne d1,loop*)
  90. CODE(06700H,0000EH);       (*           beq lesfals*)
  91. CODE(04CDFH,01803H);       (*   lestrue movem.l (sp)+,d0-d1/a3-a4*)
  92. CODE(01F7CH,00001H,0000CH);(*           move.b #1,$C(sp)*)
  93. CODE(04E75H);              (*           rts*)
  94. CODE(04CDFH,01803H);       (*   lesfals movem.l (sp)+,d0-d1/a3-a4*)
  95. CODE(0422FH,0000CH);       (*           clr.b $C(sp)*)
  96. CODE(04E75H);              (*           rts*)
  97. END ExLess;
  98.  
  99. (*$P-*)
  100. PROCEDURE ExOdd(VAR a : ExCard) : BOOLEAN;
  101. (* ODD(a) ? *)
  102. BEGIN
  103. CODE(048E7H,08080H);         (* odd     movem.l d0/a0,-(sp)*)
  104. CODE(0206FH,0000CH);         (*         movea.l 12(sp),a0*)
  105. CODE(02010H);                (*         move.l (a0),d0*)
  106. CODE(0E248H);                (*         lsr.w #1,d0*)
  107. CODE(06500H,0000CH);         (*         bcs oddtrue*)
  108. CODE(04CDFH,00101H);         (*         movem.l (sp)+,d0/a0*)
  109. CODE(0422FH,00008H);         (*         clr.b 8(sp)*)
  110. CODE(04E75H);                (*         rts*)
  111. CODE(04CDFH,00101H);         (* oddtrue movem.l (sp)+,d0/a0*)
  112. CODE(01F7CH,00001H,00008H);  (*         move.b #1,8(sp)*)
  113. CODE(04E75H);                (*         rts        *)
  114. END ExOdd;
  115.  
  116. (*$P-*)
  117. PROCEDURE ExInc(VAR a : ExCard);
  118. (*  a := a+1    *)
  119. BEGIN
  120. CODE(02F0CH);            (*             move.l a4,-(sp)*)
  121. CODE(0286FH,00008H);     (*             movea.l $8(sp),a4*)
  122. CODE(03F00H);            (*             move.w d0,-(sp)*)
  123. CODE(0301CH);            (*             move.w (a4)+,d0  *)
  124. CODE(05340H);            (*             subq.w #1,d0*)
  125. CODE(0525CH);            (*     loopsuc addq.w #1,(a4)+  *)
  126. CODE(054C8H,0FFFCH);     (*             dbcc d0,loopsuc*)
  127. CODE(06400H,0000CH);     (*             bcc exsucc0   *)
  128. CODE(038BCH,00001H);     (*             move.w #1,(a4) *) 
  129. CODE(0286FH,0000AH);     (*             movea.l $A(sp),a4 *)
  130. CODE(05254H);            (*             addq.w #1,(a4)  *)
  131. CODE(0301FH);            (*             move.w (sp)+,d0*) 
  132. CODE(0285FH);            (*             movea.l (sp)+,a4*)
  133. CODE(04E75H);            (*             rts*)
  134. END ExInc;
  135.  
  136. (*$P-*)
  137. PROCEDURE ExDec(VAR a : ExCard);
  138. (* a := a-1 *)
  139. (* ACHTUNG : ExDec(0)= runtime error #3 (arithmetic overflow) *)
  140. BEGIN
  141. CODE(048E7H,0C080H);       (*   pred    movem.l d0-d1/a0,-(sp)*)
  142. CODE(0206FH,00010H);       (*           movea.l $10(sp),a0  *)
  143. CODE(00C90H,00001H,00000H);(*           cmpi.l #$00010000,(a0)*)
  144. CODE(06600H,00008H);       (*           bne weiter*)
  145. CODE(044FCH,00002H);       (*           move.w #2,ccr*)
  146. CODE(04E76H);              (*           trapv*)
  147. CODE(03018H);              (*   weiter  move.w (a0)+,d0*)
  148. CODE(03200H);              (*           move.w d0,d1*)
  149. CODE(05340H);              (*           subq.w #1,d0*)
  150. CODE(05358H);              (*   pl7     subq.w #1,(a0)+*)
  151. CODE(054C8H,0FFFCH);       (*           dbcc d0,pl7*)
  152. CODE(04A40H);              (*           tst.w d0*)
  153. CODE(06A00H,00018H);       (*           bpl pred0*)
  154. CODE(04A60H);              (*           tst.w -(a0)*)
  155. CODE(06600H,00012H);       (*           bne pred0*)
  156. CODE(05341H);              (*           subq.w #1,d1*)
  157. CODE(04A41H);              (*           tst.w d1*)
  158. CODE(06600H,00004H);       (*           bne pred1*)
  159. CODE(05241H);              (*           addq.w #1,d1*)
  160. CODE(0206FH,00010H);       (*   pred1   movea.l $10(sp),a0*)
  161. CODE(03081H);              (*           move.w d1,(a0) *)
  162. CODE(04CDFH,00103H);       (*   pred0   movem.l (sp)+,d0-d1/a0*)
  163. CODE(04E75H);              (*           rts*)
  164. END ExDec;
  165.  
  166. (*$P-*)
  167. PROCEDURE ExAdd(VAR sum,a,b : ExCard);
  168. (* sum := a + b    *)
  169. BEGIN
  170. CODE(048E7H,00038H);      (*            movem.l a2-a4,-(sp)*)
  171. CODE(0246FH,00010H);      (*            movea.l $10(sp),a2 ;^b*)
  172. CODE(0266FH,00014H);      (*            movea.l $14(sp),a3 ;^a*)
  173. CODE(0286FH,00018H);      (*            movea.l $18(sp),a4 ;^sum*)
  174. CODE(048A7H,07C00H);      (*            movem.w d1-d5,-(sp)*)
  175. CODE(03412H);             (*            move.w (a2),d2 ;b.length*)
  176. CODE(0B453H);             (*            cmp.w (a3),d2*)
  177. CODE(06300H,00004H);      (*            bls goon   ;b<=a=true?*)
  178. CODE(0C74AH);             (*            exg a2,a3*)
  179. CODE(0341AH);             (*    goon    move.w (a2)+,d2 ;d2=a.length *)
  180. CODE(0361BH);             (*            move.w (a3)+,d3*)
  181. CODE(038C3H);             (*            move.w d3,(a4)+*)
  182. CODE(03203H);             (*            move.w d3,d1*)
  183. CODE(09242H);             (*            sub.w d2,d1*)
  184. CODE(05342H);             (*            subq.w #1,d2*)
  185. CODE(0381AH);             (*    loop0   move.w (a2)+,d4*)
  186. CODE(03A1BH);             (*            move.w (a3)+,d5*)
  187. CODE(0DB44H);             (*            addx.w d4,d5*)
  188. CODE(038C5H);             (*            move.w d5,(a4)+*)
  189. CODE(051CAH,0FFF6H);      (*            dbf d2,loop0*)
  190. CODE(00C41H,00000H);      (*            cmpi.w #0,d1*)
  191. CODE(06700H,00010H);      (*            beq end0*)
  192. CODE(0383CH,00000H);      (*            move.w #0,d4*)
  193. CODE(03A1BH);             (*    loop1   move.w (a3)+,d5*)
  194. CODE(0DB44H);             (*            addx.w d4,d5*)
  195. CODE(038C5H);             (*            move.w d5,(a4)+*)
  196. CODE(051C9H,0FFF8H);      (*            dbf d1,loop1*)
  197. CODE(040C1H);             (*    end0    move.w sr,d1*)
  198. CODE(00801H,00004H);      (*            btst.l #4,d1*)
  199. CODE(06700H,0000CH);      (*            beq end1*)
  200. CODE(038FCH,00001H);      (*            move.w #1,(a4)+*)
  201. CODE(0286FH,00022H);      (*            movea.l $22(sp),a4*)
  202. CODE(05254H);             (*            addq.w #1,(a4)*)
  203. CODE(04C9FH,0003EH);      (*    end1    movem.w (sp)+,d1-d5*)
  204. CODE(04CDFH,01C00H);      (*            movem.l (sp)+,a2-a4*)
  205. CODE(04E75H);             (*            rts*)
  206. END ExAdd ;
  207. (*$P-*)
  208. PROCEDURE ExSub(VAR diff,a,b : ExCard);
  209. (*  diff := a - b   *)
  210. (* ACHTUNG : Es muß gelten a>=b *)
  211. BEGIN
  212. CODE(048E7H,0F8F8H);        (*  sub     movem.l d0-d4/a0-a4,-(sp)*)
  213. CODE(0206FH,0002CH);        (*          movea.l 44(sp),a0 ; ^b   *)
  214. CODE(0266FH,00030H);        (*          movea.l 48(sp),a3 ; ^a   *)
  215. CODE(0286FH,00034H);        (*          movea.l 52(sp),a4 ; ^diff *)
  216. CODE(0361BH);               (*          move.w (a3)+,d3 ;a.length *)
  217. CODE(03003H);               (*          move.w d3,d0 *)
  218. CODE(03418H);               (*          move.w (a0)+,d2 ;b.length*)
  219. CODE(02448H);               (*          movea.l a0,a2*)             
  220. CODE(09042H);               (*          sub.w d2,d0 *)
  221. CODE(06700H,00012H);        (*          beq sgoon   ;a.length=b.length? *)
  222. CODE(0D442H);               (*          add.w d2,d2       *)                  
  223. CODE(045F2H,02000H);        (*          lea $0(a2,d2.w),a2*)                   
  224. CODE(05340H);               (*          subq.w #1,d0   *)                    
  225. CODE(0425AH);               (*  sloop0  clr.w (a2)+ *)                     
  226. CODE(051C8H,0FFFCH);        (*          dbf d0,sloop0 *)                     
  227. CODE(02448H);               (*          movea.l a0,a2   *)
  228. CODE(03403H);               (*  sgoon   move.w d3,d2 *)
  229. CODE(05342H);               (*          subq.w #1,d2*)
  230. CODE(038FCH,00001H);        (*          move.w #1,(a4)+ *)            
  231. CODE(0321AH);               (*  sloop1  move.w (a2)+,d1*)
  232. CODE(0381BH);               (*          move.w (a3)+,d4 *)
  233. CODE(09941H);               (*          subx.w d1,d4 *)
  234. CODE(038C4H);               (*          move.w d4,(a4)+   *)
  235. CODE(051CAH,0FFF6H);        (*          dbf d2,sloop1  *)
  236. CODE(04A64H);               (*  snext   tst.w -(a4)*)
  237. CODE(056CBH,0FFFCH);        (*          dbne d3,snext*)
  238. CODE(04A43H);               (*          tst.w d3*)
  239. CODE(06600H,00004H);        (*          bne send*)
  240. CODE(05243H);               (*          addq.w #1,d3*)
  241. CODE(0286FH,00034H);        (*  send    movea.l 52(sp),a4*)
  242. CODE(03883H);               (*          move.w d3,(a4)*)
  243. CODE(04CDFH,01F1FH);        (*          movem.l (sp)+,d0-d4/a0-a4*)
  244. CODE(04E75H);               (*          rts*)
  245. END ExSub ;
  246. (*$P-*)
  247. PROCEDURE ExWordLeft(VAR a : ExCard; c : CARDINAL);
  248. (* a := a * (2 ^ (16*c)) *)
  249. (* ACHTUNG : Es muss gelten c # 0 *)
  250. BEGIN
  251. CODE(048E7H,0E0C0H);    (*      wleft   movem.l d0-d2/a0-a1,-(sp)*)
  252. CODE(0302FH,00018H);    (*              move.w 24(sp),d0 ;value(c)*)
  253. CODE(0206FH,0001AH);    (*              movea.l 26(sp),a0 ;^a*)
  254. CODE(03210H);           (*              move.w (a0),d1*)
  255. CODE(03401H);           (*              move.w d1,d2*)
  256. CODE(0D440H);           (*              add.w d0,d2*)
  257. CODE(03082H);           (*              move.w d2,(a0)*)
  258. CODE(0D442H);           (*              add.w d2,d2*)
  259. CODE(043F0H,02002H);    (*              lea $2(a0,d2.w),a1*)
  260. CODE(03401H);           (*              move.w d1,d2*)
  261. CODE(0D442H);           (*              add.w d2,d2*)
  262. CODE(041F0H,02002H);    (*              lea $2(a0,d2.w),a0*)
  263. CODE(05341H);           (*              subq.w #1,d1*)
  264. CODE(03320H);           (*      wloop1  move.w -(a0),-(a1)*)
  265. CODE(051C9H,0FFFCH);    (*              dbf d1,wloop1*)
  266. CODE(05340H);           (*              subq.w #1,d0*)
  267. CODE(04261H);           (*      wloop2  clr.w -(a1)*)
  268. CODE(051C8H,0FFFCH);    (*              dbf d0,wloop2*)
  269. CODE(04CDFH,00307H);    (*      wend    movem.l (sp)+,d0-d2/a0-a1*)
  270. CODE(04E75H);           (*              rts*)
  271. END ExWordLeft;
  272. (*$P-*)
  273. PROCEDURE ExShl(VAR a : ExCard);
  274. (* a := a * 2 *)
  275. BEGIN
  276. CODE(048E7H,08008H);    (*              movem.l d0/a4,-(sp)*)
  277. CODE(0286FH,0000CH);    (*              movea.l $C(sp),a4*)
  278. CODE(0301CH);           (*              move.w (a4)+,d0*)
  279. CODE(05340H);           (*              subq.w #1,d0*)
  280. CODE(0E5DCH);           (*      loop    roxl.w (a4)+*)
  281. CODE(051C8H,0FFFCH);    (*              dbf d0,loop*)
  282. CODE(06400H,0000CH);    (*              bcc end*)
  283. CODE(038BCH,00001H);    (*              move.w #1,(a4)*)
  284. CODE(0286FH,0000CH);    (*              movea.l $C(sp),a4*)
  285. CODE(05254H);           (*              addq.w #1,(a4)*)
  286. CODE(04CDFH,01001H);    (*      end     movem.l (sp)+,d0/a4*)
  287. CODE(04E75H);           (*              rts*)
  288. END ExShl;
  289. (*$P-*)
  290. PROCEDURE ExShr(VAR a : ExCard):BOOLEAN;
  291. (* a := a DIV 2; herausgeschobenes Bit bestimmt BOOLEAN-Wert *)
  292. BEGIN
  293. CODE(048E7H,08030H);        (*  shr     movem.l d0/a2-a3,-(sp)*)
  294. CODE(0266FH,00010H);        (*          movea.l $10(sp),a3*)
  295. CODE(03013H);               (*          move.w (a3),d0*)
  296. CODE(0D040H);               (*          add.w d0,d0*)
  297. CODE(047F3H,00002H);        (*          lea $2(a3,d0.w),a3*)
  298. CODE(0244BH);               (*          movea.l a3,a2*)
  299. CODE(0E248H);               (*          lsr.w #1,d0*)
  300. CODE(05340H);               (*          subq.w #1,d0*)
  301. CODE(0E4E3H);               (*  l10     roxr.w -(a3)*)
  302. CODE(051C8H,0FFFCH);        (*          dbf d0,l10*)
  303. CODE(06400H,0000AH);        (*          bcc shrfals*)
  304. CODE(01F7CH,00001H,00014H); (*          move.b #1,$14(sp)*)
  305. CODE(06004H);               (*          bra.s shrnext*)
  306. CODE(0422FH,00014H);        (*  shrfals clr.b $14(sp)*)
  307. CODE(04A62H);               (*  shrnext tst.w -(a2)*)
  308. CODE(06600H,0000CH);        (*          bne shrend*)
  309. CODE(00C63H,00001H);        (*          cmp.w #1,-(a3)*)
  310. CODE(06700H,00004H);        (*          beq shrend*)
  311. CODE(05353H);               (*          subq.w #1,(a3)*)
  312. CODE(04CDFH,00C01H);        (*  shrend  movem.l (sp)+,d0/a2-a3*)
  313. CODE(04E75H);               (*          rts*)
  314. END ExShr ;
  315. (*$P+*)
  316.  
  317.  
  318. PROCEDURE ExMul(VAR prod,a,b : ExCard);
  319. (*  prod := a * b  *)
  320. VAR dummy0,dummy1,null,temp : ExCard;
  321.  
  322. (*$P-*)
  323. PROCEDURE Mul(VAR p0,a0,b0 : ExCard);
  324. BEGIN
  325. CODE(048E7H,000FCH);          (*        movem.l a0-a5,-(sp)*)
  326. CODE(048A7H,0FE00H);          (*        movem.w d0-d6,-(sp)*)
  327. CODE(0206FH,0002AH);          (*        movea.l 42(sp),a0*)
  328. CODE(0226FH,0002EH);          (*        movea.l 46(sp),a1*)
  329. CODE(0246FH,00032H);          (*        movea.l 50(sp),a2*)
  330. CODE(03018H);                 (*        move.w (a0)+,d0*)
  331. CODE(03C00H);                 (*        move.w d0,d6*)
  332. CODE(03219H);                 (*        move.w (a1)+,d1*)
  333. CODE(05340H);                 (*        subq.w #1,d0*)
  334. CODE(03419H);                 (*        move.w (a1)+,d2*)
  335. CODE(02648H);                 (*        movea.l a0,a3*)
  336. CODE(04284H);                 (*        clr.l d4*)
  337. CODE(03A00H);                 (*        move.w d0,d5*)
  338. CODE(0284AH);                 (*        movea.l a2,a4*)
  339. CODE(038FCH,00001H);          (*        move.w #1,(a4)+*)
  340. CODE(02A4CH);                 (*        movea.l a4,a5*)
  341. CODE(03602H);                 (*mul0    move.w d2,d3*)
  342. CODE(0C6DBH);                 (*        mulu.w (a3)+,d3*)
  343. CODE(0D684H);                 (*        add.l d4,d3*)
  344. CODE(038C3H);                 (*        move.w d3,(a4)+*)
  345. CODE(04843H);                 (*        swap d3*)
  346. CODE(03803H);                 (*        move.w d3,d4*)
  347. CODE(051CDH,0FFF2H);          (*        dbf d5,mul0*)
  348. CODE(038C4H);                 (*        move.w d4,(a4)+*)
  349. CODE(05246H);                 (*        addq.w #1,d6*)
  350. CODE(05541H);                 (*        subq.w #2,d1*)
  351. CODE(06B00H,00030H);          (*        bmi back*)
  352. CODE(03419H);                 (*mul1    move.w (a1)+,d2*)
  353. CODE(04284H);                 (*        clr.l d4*)
  354. CODE(02648H);                 (*        movea.l a0,a3*)
  355. CODE(03A00H);                 (*        move.w d0,d5*)
  356. CODE(0548DH);                 (*        addq.l #2,a5*)
  357. CODE(0284DH);                 (*        movea.l a5,a4*)
  358. CODE(03602H);                 (*mul2    move.w d2,d3*)
  359. CODE(0C6DBH);                 (*        mulu.w (a3)+,d3*)
  360. CODE(0D684H);                 (*        add.l d4,d3*)
  361. CODE(0D75CH);                 (*        add.w d3,(a4)+*)
  362. CODE(06400H,00008H);          (*        bcc next0*)
  363. CODE(04843H);                 (*        swap d3*)
  364. CODE(05243H);                 (*        addq.w #1,d3*)
  365. CODE(06002H);                 (*        bra.s next1*)
  366. CODE(04843H);                 (*next0   swap d3*)
  367. CODE(03803H);                 (*next1   move.w d3,d4*)
  368. CODE(051CDH,0FFE8H);          (*        dbf d5,mul2*)
  369. CODE(038C4H);                 (*        move.w d4,(a4)+*)
  370. CODE(05246H);                 (*        addq.w #1,d6*)
  371. CODE(051C9H,0FFD4H);          (*        dbf d1,mul1*)
  372. CODE(05346H);                 (*back    subq.w #1,d6*)
  373. CODE(04A64H);                 (*        tst.w -(a4)*)
  374. CODE(06700H,0FFFAH);          (*        beq back*)
  375. CODE(05246H);                 (*        addq.w #1,d6*)
  376. CODE(04A46H);                 (*        tst.w d6*)
  377. CODE(06600H,00008H);          (*        bne next2*)
  378. CODE(034BCH,00001H);          (*        move.w #1,(a2)*)
  379. CODE(06002H);                 (*        bra.s next3*)
  380. CODE(03486H);                 (*next2   move.w d6,(a2)*)
  381. CODE(04C9FH,0007FH);          (*next3   movem.w (sp)+,d0-d6*)
  382. CODE(04CDFH,03F00H);          (*        movem.l (sp)+,a0-a5*)
  383. CODE(04E75H);                 (*        rts*)
  384. END Mul;
  385. (*$P+*)
  386. BEGIN
  387.   IF (ADR(a)=ADR(prod)) & (ADR(b)=ADR(prod)) THEN 
  388.     Def(dummy0,ADR(a));
  389.     Def(dummy1,ADR(b));
  390.     Mul(prod,dummy0,dummy1);
  391.   ELSIF ADR(a)=ADR(prod) THEN 
  392.     Def(dummy0,ADR(a));
  393.     Mul(prod,dummy0,b);    
  394.   ELSIF ADR(b)=ADR(prod) THEN 
  395.     Def(dummy0,ADR(b));
  396.     Mul(prod,a,dummy0); 
  397.   ELSE
  398.     Mul(prod,a,b);
  399.   END;     
  400. END ExMul ;
  401.  
  402. PROCEDURE ExDiv(VAR quot,a,b : ExCard);
  403. (* quot := a DIV b     *)
  404. VAR rest,temp,q        : ExCard;
  405.     len,blen           : CARDINAL; 
  406.     dummy              : BOOLEAN;
  407. BEGIN
  408.   Def(rest,ADR(a));
  409.   CardToExCard(quot,0);
  410.   blen:=b.length;
  411.   WHILE NOT ExLess(rest,b) DO
  412.     CardToExCard(q,1);
  413.     Def(temp,ADR(b));
  414.     len:=rest.length-blen;
  415.     IF len>0 THEN
  416.       ExWordLeft(temp,len);
  417.       ExWordLeft(q,len)
  418.     END;
  419.     IF ExLess(temp,rest) THEN
  420.       REPEAT 
  421.         ExShl(temp);
  422.         ExShl(q);
  423.       UNTIL ExLess(rest,temp);
  424.       dummy:=ExShr(temp);
  425.       dummy:=ExShr(q);
  426.     ELSIF ExLess(rest,temp) THEN
  427.       REPEAT 
  428.         dummy:=ExShr(temp);
  429.         dummy:=ExShr(q);
  430.       UNTIL NOT ExLess(rest,temp);
  431.     END;
  432.     ExSub(rest,rest,temp);
  433.     ExAdd(quot,quot,q);
  434.   END
  435. END ExDiv;
  436.  
  437. PROCEDURE ExMod(VAR rest,a,b : ExCard);
  438. (* rest := a MOD b *)
  439. VAR temp0,temp,zw : ExCard;
  440.     len,i,blen    : CARDINAL;
  441.     dummy         : BOOLEAN;
  442. BEGIN
  443.   Def(rest,ADR(a));                    (* rest:=a *)
  444.   blen:=b.length;
  445.   WHILE NOT ExLess(rest,b) DO          (* rest>=b ? *)
  446.     Def(temp,ADR(b));                    (* temp:=b *)
  447.     len:=rest.length-blen;
  448.     IF len>0 THEN
  449.       ExWordLeft(temp,len);                (* temp:=temp*2^(16*len) *)
  450.     END;
  451.     IF ExLess(temp,rest) THEN            (* temp<rest ? *)
  452.       REPEAT 
  453.         ExShl(temp)
  454.       UNTIL ExLess(rest,temp);
  455.       dummy:=ExShr(temp)
  456.     ELSIF ExLess(rest,temp) THEN         (* rest<temp ? *)
  457.       REPEAT 
  458.         dummy:=ExShr(temp)
  459.       UNTIL NOT ExLess(rest,temp);         (* bis rest>=temp *)
  460.     END;
  461.     ExSub(rest,rest,temp);
  462.   END;
  463. END ExMod ;  
  464.  
  465. PROCEDURE ExRead(VAR a : ExCard);
  466. VAR i,j,len,mov: CARDINAL;
  467.     lin        : String;
  468.     m          : LONGCARD;
  469.  
  470. BEGIN
  471.   CardToExCard(a,0);
  472.   WriteLn; 
  473.   ReadString(lin);
  474.   i:=0;
  475.   WHILE i < Length(lin) DO
  476.     IF ('0' <= lin[i]) & (lin[i] <= '9') THEN 
  477.       mov:=ORD(lin[i])-ORD('0');
  478.       FOR j:=0 TO a.length-1 DO
  479.         m:=LONGCARD(a.number[j])*10+LONGCARD(mov);
  480.         a.number[j]:=CARDINAL(m);
  481.         mov:=CARDINAL(m DIV TwoPow16);
  482.       END;
  483.       IF mov # 0 THEN 
  484.         INC(a.length);
  485.         a.number[a.length-1]:=mov
  486.       END;
  487.       INC(i)
  488.     ELSE
  489.       WriteString('Wrong INPUT in procedure ExWrite');
  490.       HALT;
  491.     END
  492.   END
  493. END ExRead ;
  494.  
  495. PROCEDURE ExWrite( a : ExCard);
  496. VAR i,j,k,l      : INTEGER;
  497.     m,mov        : LONGCARD;
  498.     buffer       : ARRAY [0..ExCardDigits] OF CHAR;
  499.     pch          : pChar;
  500.     pcard,pjcard : pCard;
  501. BEGIN
  502. (* Schnelle Ausgabe nur fuer weniger als 80 Zeichen geeignet
  503.    Compileroption P- vor Prozedur setzen
  504. CODE(048E7H,0F8F0H);       (*   lwrite  movem.l d0-d4/a0-a3,-(sp)*)
  505. CODE(0246FH,00028H);       (*           movea.l 40(sp),a2*)
  506. CODE(04E56H,-ExCardDigits-2*ExCardLen-2);  
  507.                            (*        link a6,#-ExCardDigits-2*ExCardLen-2*)
  508. CODE(043EEH,-ExCardDigits-2*ExCardLen-2);    
  509.                            (*        lea -ExCardDigits-2*ExCardLen-2(a6),a1*)
  510. CODE(041EEH,-(2*ExCardLen)-2);(*        lea -(2*ExCardLen)-2(a6),a0*)
  511. CODE(03012H);              (*           move.w (a2),d0*)
  512. CODE(030DAH);              (*   wr0     move.w (a2)+,(a0)+ *)       
  513. CODE(051C8H,0FFFCH);       (*           dbf d0,wr0*)
  514. CODE(041EEH,-(2*ExCardLen)-2);(*        lea -(2*ExCardLen)-2(a6),a0*)
  515. CODE(00C90H,00001H,00000H);(*           cmpi.l #$00010000,(a0)*)
  516. CODE(06600H,0000AH);       (*           bne wr1*)
  517. CODE(07801H);              (*           moveq.l #1,d4*)
  518. CODE(032FCH,00030H);       (*           move.w #$30,(a1)+*)
  519. CODE(06046H);              (*           bra.s n2*)
  520. CODE(03010H);              (*   wr1     move.w (a0),d0*)
  521. CODE(05340H);              (*           subq.w #1,d0*)
  522. CODE(04244H);              (*           clr.w d4*)
  523. CODE(03400H);              (*   l3      move.w d0,d2*)
  524. CODE(0D442H);              (*           add.w d2,d2*)
  525. CODE(045F0H,02004H);       (*           lea $4(a0,d2.w),a2*)
  526. CODE(0264AH);              (*           movea.l a2,a3*)
  527. CODE(04A63H);              (*           tst.w -(a3)*)
  528. CODE(06600H,0000AH);       (*           bne n1*)
  529. CODE(051C8H,0FFEEH);       (*           dbf d0,l3*)
  530. CODE(06000H,0002AH);       (*           bra n2*)
  531. CODE(03400H);              (*   n1      move.w d0,d2*)
  532. CODE(04241H);              (*           clr.w d1*)
  533. CODE(04283H);              (*   l2      clr.l d3*)
  534. CODE(03622H);              (*           move.w -(a2),d3*)
  535. CODE(04841H);              (*           swap d1*)
  536. CODE(04241H);              (*           clr.w d1*)
  537. CODE(0D681H);              (*           add.l d1,d3*)
  538. CODE(086FCH,0000AH);       (*           divu.w #$A,d3*)
  539. CODE(03483H);              (*           move.w d3,(a2)*)
  540. CODE(04843H);              (*           swap d3*)
  541. CODE(03203H);              (*           move.w d3,d1*)
  542. CODE(051CAH,0FFEAH);       (*           dbf d2,l2*)
  543. CODE(00601H,00030H);       (*           add.b #$30,d1*)
  544. CODE(012C1H);              (*           move.b d1,(a1)+*)
  545. CODE(05244H);              (*           addq.w #1,d4*)
  546. CODE(06000H,0FFC2H);       (*           bra l3*)
  547. CODE(04241H);              (*   n2      clr.w d1*)
  548. CODE(05344H);              (*           subq.w #1,d4*)
  549. CODE(01221H);              (*   l4      move.b -(a1),d1*)
  550. CODE(03F01H);              (*           move.w d1,-(sp)*)
  551. CODE(03F3CH,00002H);       (*           move.w #2,-(sp)*)
  552. CODE(04E41H);              (*           trap #1*)
  553. CODE(0588FH);              (*           addq.l #4,sp*)
  554. CODE(051CCH,0FFF2H);       (*           dbf d4,l4*)
  555. CODE(04E5EH);              (*           unlk a6*)
  556. CODE(04CDFH,00F1FH);       (*           movem.l (sp)+,d0-d4/a0-a3*)
  557. CODE(04E75H);              (*           rts*)*)
  558.   WriteLn; (* Ausgabe nur am Anfang einer Zeile ! *)
  559.   IF (a.length=1) & (a.number[0]=0) THEN
  560.     Write('0')
  561.   ELSE
  562.     j:=a.length-1;
  563.     pch:=ADR(buffer[0]);
  564.     k:=-1;
  565.     REPEAT
  566.       IF a.number[j]=0 THEN
  567.         DEC(j)
  568.       ELSE 
  569.         mov:=0;
  570.         INC(k);
  571.         pcard:=ADR(a.number[j]);
  572.         FOR i:=j TO 0 BY -1 DO
  573.           m:=LONGCARD(pcard^)+mov * TwoPow16;
  574.           pcard^:=CARDINAL(m DIV 10);
  575.           (*$T-*)
  576.           DEC(pcard,2);
  577.           (*$T=*)
  578.           mov:=m MOD 10
  579.         END;
  580.         pch^:=CHR(CARDINAL(ORD('0')+mov));
  581.         (*$T-*)
  582.         INC(pch,1);
  583.         (*$T=*)
  584.       END;
  585.     UNTIL j=-1;
  586.     l:=0;
  587.     FOR i:=k TO 0 BY -1 DO
  588.       (*$T-*)
  589.       DEC(pch,1);
  590.       (*$T=*)
  591.       Write(pch^);
  592.       INC(l);
  593.       IF l=80 THEN
  594.         WriteLn;
  595.         l:=0;
  596.       END;
  597.     END
  598.   END
  599. END ExWrite ;
  600.  
  601. END Excard.  
  602.